home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / stringsLists.tcl < prev    next >
Encoding:
Text File  |  2000-10-16  |  12.7 KB  |  462 lines
  1. #  AlphaTcl - core Tcl engine
  2. #
  3. # strings.tcl (Mark Nagata and Tom Scavo and Vince Darley)
  4. #
  5.  
  6. ## 
  7.  # -------------------------------------------------------------------------
  8.  # 
  9.  # "lremove" --
  10.  # 
  11.  #  removes items from a list
  12.  #  
  13.  #  options are '-all' to remove all, and -glob, -exact or -regexp
  14.  #  for search type.  '-exact' is the default. '--' terminates options.
  15.  #  
  16.  #  lremove ?-opts? l args
  17.  #  
  18.  #  Note: if you want to remove all items of list 'b' from list 'a',
  19.  #  the following is incorrect: lremove $a $b, you must use
  20.  #  'eval lremove [list $a] $b', so that b is expanded.
  21.  #  
  22.  #  There is now a new option -l which treats the extra args as lists,
  23.  #  so you can do lremove -l $a $b if you want.
  24.  # -------------------------------------------------------------------------
  25.  ##
  26. proc lremove {args} {
  27.     set opts(-all) 0
  28.     set type "-exact"
  29.     getOpts
  30.     set l [lindex $args 0]
  31.     if {[info exists opts(-glob)]} { set type "-glob" }
  32.     if {[info exists opts(-regexp)]} { set type "-regexp" }
  33.     if {[info exists opts(-l)]} { 
  34.     set args [join [lreplace $args 0 0] " "]
  35.     } else {
  36.     set args [lreplace $args 0 0]
  37.     }
  38.     foreach i $args {
  39.     if {[set ix [lsearch $type $l $i]] == -1} continue
  40.     set l [lreplace $l $ix $ix]
  41.     if {$opts(-all)} {
  42.         while {[set ix [lsearch $type $l $i]] != -1} {
  43.         set l [lreplace $l $ix $ix]
  44.         }
  45.     }
  46.     }
  47.     return $l
  48. }
  49.  
  50. ## 
  51.  # -------------------------------------------------------------------------
  52.  # 
  53.  # "getOpts" --
  54.  # 
  55.  #  Rudimentary option passing.  Uses upvar to get to the 'args' list
  56.  #  of the calling procedure and scans that.  Option information is
  57.  #  stored in the 'opts' array of the calling procedure.
  58.  #  
  59.  #  Options are assumed to be flags, unless they occur in the
  60.  #  optional parameter list.  Then they are variables which take a
  61.  #  value; the next item in the args list.  If an item is a pair,
  62.  #  then the first is the var name and the second the number of
  63.  #  arguments to give it.
  64.  # -------------------------------------------------------------------------
  65.  ##
  66. proc getOpts {{take_value ""} {set "set"}} {
  67.     upvar args a
  68.     upvar opts o
  69.     while {[string match \-* [set arg [lindex $a 0]]]} {
  70.     set a [lreplace $a 0 0]
  71.     if {$arg == "--"} {
  72.         return
  73.     } else {
  74.         if {[set idx [lsearch -regexp $take_value \
  75.           "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  76.         set o($arg) 1
  77.         } else {
  78.         if {[llength [set the_arg \
  79.           [lindex $take_value $idx]]] == 1} {
  80.             $set o($arg) [lindex $a 0]
  81.             set a [lreplace $a 0 0]
  82.         } else {
  83.             set numargs [expr {[lindex $the_arg 1] -1}]
  84.             $set o($arg) [lrange $a 0 $numargs]
  85.             set a [lreplace $a 0 $numargs]
  86.         }
  87.         }
  88.     }
  89.     }
  90. }
  91.  
  92. ## 
  93.  # -------------------------------------------------------------------------
  94.  # 
  95.  # "ensureset" --
  96.  # 
  97.  #  Ensure the given variable is set, if it is unset, set it to the given
  98.  #  value.  This works with both variables and array elements, including
  99.  #  things which contain spaces etc.
  100.  # -------------------------------------------------------------------------
  101.  ##
  102. proc ensureset {v {val ""}} {
  103.     if {[uplevel [list info exists $v]]} { return [uplevel [list set $v]] }
  104.     return [uplevel [list set $v $val]]
  105. }
  106. ## 
  107.  # -------------------------------------------------------------------------
  108.  # 
  109.  # "lunion" --
  110.  # 
  111.  #  Basic use: make sure a given list variable contains each element 
  112.  #  of 'args'
  113.  #  
  114.  #  "llunion" --
  115.  #  
  116.  #  Advanced use: make sure a given list variable and index contains
  117.  #  an element whose i'th index matches the i'th index of one of 'args'.
  118.  #  In this case we call the proc with a list {var i} as first argument.
  119.  # -------------------------------------------------------------------------
  120.  ##
  121. proc lunion {var args} {
  122.     upvar $var a
  123.     if {![info exists a]} {
  124.     set a $args
  125.     return
  126.     } else {
  127.     foreach item $args {
  128.         if {[lsearch $a $item] == -1} {
  129.         lappend a $item
  130.         }
  131.     }
  132.     }
  133. }
  134.     
  135. proc llunion {var idx args} {
  136.     upvar $var a
  137.     if {![info exists a]} {
  138.     set a $args
  139.     return
  140.     } else {
  141.     foreach item $args {
  142.         set add 1
  143.         foreach i $a {
  144.         if {[lindex $i $idx] == [lindex $item $idx]} {
  145.             set add 0
  146.             break
  147.         }
  148.         }
  149.         if {$add} {
  150.         lappend a $item
  151.         }
  152.     }
  153.     }
  154. }
  155.  
  156. proc lunique {l} {
  157.     set lout ""
  158.     foreach f $l {
  159.     if {![info exists silly($f)]} {
  160.         set silly($f) 1
  161.         lappend lout $f
  162.     }
  163.     }
  164.     return $lout
  165. }
  166.             
  167. proc lreverse {l} {
  168.     if {[llength $l] > 1} {
  169.     set first [lindex $l 0]
  170.     set l [lreverse [lrange $l 1 end]]
  171.     lappend l $first
  172.     }
  173.     return $l
  174. }
  175.  
  176. proc lcontains {l e} {
  177.     upvar $l ll
  178.     if {[info exists ll] && [lsearch -exact $ll $e] != -1} {
  179.     return 1
  180.     } else {
  181.     return 0
  182.     }
  183. }
  184.  
  185. ## 
  186.  # -------------------------------------------------------------------------
  187.  # 
  188.  # "llindex" --
  189.  # 
  190.  #  Find the first index of a given list within another list.  
  191.  # -------------------------------------------------------------------------
  192.  ##
  193. proc llindex {l e args} {
  194.     upvar $l ll
  195.     if {![info exists ll]} { return -1 }
  196.     if {![llength $args]} {
  197.     return [lsearch -exact $ll $e]
  198.     } else {
  199.     set i 0
  200.     set len [llength $args]
  201.     while {$i < [llength $ll] - $len} {
  202.         if {[lindex $ll $i] == $e} {
  203.         set range [lrange $ll [expr {$i +1}] [expr {$i + $len}]]
  204.         for {set j 0} {$j < $len} {incr j} {
  205.             if {[lindex $args $j] != [lindex $range $j]} {
  206.             break
  207.             }
  208.         }
  209.         if {$j == $len} { return $i}
  210.         }
  211.         incr i
  212.     }
  213.     return -1
  214.     }
  215. }
  216.  
  217. # Returns a modified text string if the string $text is non-null, 
  218. # and the null string otherwise.  The argument 'operation' is a 
  219. # string directing 'doSuffixText' to either "insert" or "remove" 
  220. # $suffixString to/from each line of $text.
  221. proc doSuffixText {operation suffixString text} {
  222.     if {$text == ""} {return ""}
  223.     if {$operation == "insert"} {
  224.     regsub -all "\[\r\n\]" $text "[quote::Regsub ${suffixString}]\r" text
  225.     } elseif {$operation == "remove"} {
  226.     regsub -all -- "[quote::Regfind $suffixString]\r" $text "\r" text
  227.     }
  228.     return $text
  229. }
  230.  
  231. # Returns a modified text string if the string $text is non-null, 
  232. # and the null string otherwise.  The argument 'operation' is a 
  233. # string directing 'doPrefixText' to either "insert" or "remove" 
  234. # $prefixString to/from each line of $text.  
  235. proc doPrefixText {operation prefixString text} {
  236.     if {$operation == "insert"} {
  237.     set trailChar ""
  238.     set textLen [string length $text]
  239.     if {$textLen && ([is::Eol [string index $text [expr {$textLen-1}]]])} {
  240.         set text [string range $text 0 [expr {$textLen-2}]]
  241.         set trailChar "\r"
  242.     }
  243.     regsub -all \r $text "\r[quote::Regsub $prefixString]" text
  244.     return $prefixString$text$trailChar
  245.     } elseif {$operation == "remove"} {
  246.     set pref [quote::Regfind $prefixString]
  247.     regsub -all \r$pref $text \r text
  248.     regsub ^$pref $text "" text
  249.     return $text
  250.     }
  251. }
  252.  
  253. namespace eval text {}
  254.  
  255. proc text::british {v} {
  256.     uplevel "regsub -all -nocase {(Colo)r} \[set $v\] {\\1ur} $v"
  257. }
  258.  
  259. if {[llength [info commands getAscii]]} {rename getAscii {}}
  260. proc getAscii {} {
  261.     set c [lookAt [getPos]]
  262.     scan $c %c decVal
  263.     set asOctal [format %o $decVal]
  264.     set asHex   [format %x $decVal]
  265.     alertnote "saw a \"$c\", $decVal -decimal,\
  266.       \\$asOctal -octal, x$asHex -hex"
  267. }
  268.  
  269. # nabbed from html mode
  270. set text::_Ascii "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  271. append text::_Ascii "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  272. append text::_Ascii " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  273. append text::_Ascii "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  274. append text::_Ascii "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  275. append text::_Ascii "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  276. proc text::Ascii {char {num 0}} {
  277.     if {$char == ""} {return 0}
  278.     global text::_Ascii
  279.     if {$num} {
  280.     if {$char > 256 || $char < 1} { beep ; message "text::Ascii called with bad argument" }
  281.     return [string index ${text::_Ascii} [expr {$char - 1}]]
  282.     } else {
  283.     return [expr {1 + [string first $char ${text::_Ascii}]}]
  284.     }
  285. }
  286.  
  287. proc text::fromPstring {str} {
  288.     set len [text::Ascii [string index $str 0]]
  289.     return [string range $str 1 $len]
  290. }
  291.  
  292. # Useful for -command flag of 'lsort'.
  293. proc sortByTail {one two} {
  294.     string compare [file tail $one] [file tail $two]
  295. }
  296.  
  297.  
  298. namespace eval is {}
  299.  
  300. proc is::Hexadecimal {str} {
  301.     return [regexp {^[0-9a-fA-F]+$} [string trim $str]]
  302. }
  303.  
  304. proc is::Numeric {str} {
  305.     return [expr {![catch {expr {$str}}]}]
  306. }
  307.  
  308. proc is::Integer {str1} {
  309.     return [regexp {^(\+|-)?[0-9]+$} [string trim $str1]]
  310. }
  311.  
  312. proc is::UnsignedInteger {str1} {
  313.     return [regexp {^[0-9]+$} [string trim $str1]]
  314. }
  315.  
  316. proc is::PositiveInteger {str1} {
  317.     if {[is::UnsignedInteger $str1]} {
  318.     return [expr {$str1 > 0}]
  319.     }
  320.     return 0
  321. }
  322.  
  323. # Takes any string and tests whether or not that string contains all 
  324. # whitespace characters.  Carriage returns are considered whitespace, 
  325. # as are spaces and tabs.  Also returns true for the null string.
  326. proc is::Whitespace {anyString} {
  327.     return [regexp "^\[ \t\r\n\]*$" $anyString]
  328. }
  329.  
  330. proc is::Eol {anyString} {
  331.     return [regexp "^\[\r\n\]+$" $anyString]
  332. }
  333.  
  334. proc is::List {str} {
  335.     expr ![catch {eval list $str}]
  336. }
  337.  
  338. ###########################################################################
  339. #  Parse a string into "word"s, which include blocks of non-space text,
  340. #  double- and single-quoted strings, and blocks of text enclosed in 
  341. #  balanced parentheses or curly brackets.
  342. #
  343. #  If a word is delimited by a quote or paren character (\", \', \(, or \{),
  344. #  then _that_ particular delimiter may be included within the word if it is 
  345. #  backslash-quoted, as above.  No other characters are special or need quoting
  346. #  with that word.  The quoted delimiters are unquoted in the list of words 
  347. #  returned.  
  348. #
  349. proc parseWords {entry} {
  350.     set slash "\\"
  351.     set qslash "\\\\"
  352.     
  353.     set words {}
  354.     set entry [string trim $entry]
  355.     
  356.     while {[string length $entry]} {
  357.     set delim [string range $entry 0 0]
  358.     set entry [string range $entry 1 end]
  359.     
  360.     #        regexp $endPat   matches the end of the word
  361.     #               $openPat  matches the open delimiter
  362.     #               $unescPat matches escaped instances of the open/close delimiters
  363.     #
  364.     #        $type == "quote" means open/close delimiters are the same
  365.     #              == "paren" means there's a close delimiter and nesting is possible
  366.     #              == "unquoted" means the word is delimited by whitespace.
  367.     #
  368.     if {$delim == {"}} {            
  369.         set endPat {^([^"]*)"}
  370.         set unescPat {\\(")}
  371.         set type quote
  372.         
  373.     } elseif {$delim == {'}} {        
  374.         set endPat {^([^']*)'}
  375.         set unescPat {\\(')}
  376.         set type quote
  377.         
  378.     } elseif {$delim == "\{"} {        
  379.         set endPat "^(\[^\}\]*)\}"
  380.         set openPat "\{"
  381.         set unescPat "\\\\(\[\{\}\])"
  382.         set type paren
  383.         
  384.     } elseif {$delim == "("} {        
  385.         set endPat {^([^)]*)\)}
  386.         set openPat {(}
  387.         set unescPat {\\([()])}
  388.         set type paren
  389.         
  390.     } elseif {$delim == "\["} {        
  391.         set endPat {^([^]]*)\]}
  392.         set openPat {[}
  393.         set unescPat {\\([][])}
  394.         set type paren
  395.         
  396.     } else {                        
  397.         set type unquoted
  398.     }
  399.     
  400.     if {$type == "quote"} {
  401.         set ck $qslash
  402.         set fld ""
  403.         while {$ck == $qslash} {
  404.         set ok [regexp -indices -- $endPat $entry mtch sub1]
  405.         if {$ok} {
  406.             append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  407.             set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  408.             set pos [expr {1 + [lindex $mtch 1]}]
  409.             set entry [string range $entry $pos end]
  410.         } else {
  411.             error "Couldn't match $delim as field delimiter"
  412.         }
  413.         }
  414.         set pos [expr {[string length $fld] - 2}]
  415.         set fld [string range $fld 0 $pos]
  416.         regsub -all -- $unescPat $fld {\1} fld
  417.         
  418.     } elseif {$type == "paren"} {
  419.         
  420.         set nopen 1
  421.         set nclose 0
  422.         set fld ""
  423.         while {$nopen - $nclose != 0} {
  424.         set ok [regexp -indices -- $endPat $entry mtch sub1]
  425.         if {$ok} {
  426.             append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  427.             set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  428.             set entry [string range $entry [expr {1 + [lindex $mtch 1]}] end]
  429.             regsub -all -- $unescPat $fld {} fld1
  430.             set nopen [llength [split $fld1 $openPat]]
  431.             if {$ck != $qslash} { incr nclose }
  432.         } else {
  433.             error "Couldn't match $delim as field delimiter"
  434.         } 
  435.         }
  436.         set pos [expr {[string length $fld] - 2}]
  437.         set fld [string range $fld 0 $pos]
  438.         regsub -all -- $unescPat $fld {\1} fld
  439.         
  440.     } elseif {$type == "unquoted"} {
  441.         
  442.         set entry ${delim}${entry}
  443.         set ok [regexp -indices {^([^     ]*)} $entry mtch sub1]
  444.         if {$ok} {
  445.         set fld [string range $entry [lindex $sub1 0] [lindex $sub1 1]]
  446.         set pos [expr {1 + [lindex $mtch 1]}]
  447.         set entry [string range $entry $pos end]
  448.         } else {
  449.         set fld ""
  450.         set entry ""
  451.         }
  452.     } else {
  453.         error "parseWords: unrecognized case"
  454.     }
  455.     
  456.     lappend words $fld
  457.     set entry [string trimleft $entry]
  458.     }
  459.     return $words
  460. }
  461.  
  462.